home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / build / index.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  7.0 KB  |  195 lines
  1. (* copyright CMU ? *)
  2. (* build/index.sml *)
  3.  
  4. signature INDEX = sig
  5.   val report : Source.inputSource -> (Absyn.dec * Modules.env) -> unit
  6.   val openIndexFile :string -> outstream option
  7. end;
  8.  
  9. structure Index : INDEX = struct
  10.  
  11. open Absyn Types Variables Modules
  12.  
  13. val DEBUG = false
  14.  
  15. fun index_file_name (name :string) :string =
  16.   let fun split (dirname as ("/"::rest)) filename = (rev dirname, filename)
  17.         | split (c::rest) filename = split rest (c::filename)
  18.     | split [] filename = ([], filename)
  19.       val (dirname, filename) = (split (rev (explode name)) [])
  20.   in implode(dirname @ ("."::"i"::"."::filename))
  21.   end
  22.  
  23. fun openIndexFile (fname :string) =
  24.     if !System.Control.indexing
  25.     then if !System.Control.markabsyn
  26.          then SOME (open_out(index_file_name fname))
  27.               handle Io s =>
  28.         (System.Print.say("[cannot open index file, "^s^"]\n"); NONE)
  29.          else (System.Print.say
  30.             "[indexing is turned on, but markabsyn is turned off]\n";
  31.            NONE)
  32.     else NONE
  33.  
  34. fun report ({indexStream=NONE,...}:Source.inputSource) _ = ()
  35.   | report (inputSource as {fileName, indexStream = SOME istream,...}) 
  36.            (absyn :Absyn.dec, env: Modules.env) =
  37.   let val current_pos = ref 0 and limit_pos = ref 0
  38.     fun withpos(L1,L2,f) = let val c = !current_pos and l = !limit_pos
  39.                         in current_pos := L1; limit_pos := L2;
  40.                    f() before (current_pos := c; limit_pos := l)
  41.                    handle e => (current_pos := c; limit_pos := l;
  42.                         raise e)
  43.                end 
  44.  
  45.     val and_seq :bool ref = ref(false)
  46.  
  47.     val formatQid = PrintUtil.formatQid
  48.     val say = outputc istream
  49.  
  50.     fun nl () = (say "\n"; PPType.resetPPType())
  51.  
  52.     fun print_type (typ :ty) :unit =
  53.     PrettyPrint.with_pp
  54.      {consumer=say,linewidth=79,flush=(fn () => flush_out istream)}
  55.      (fn ppstrm =>
  56.       (PrettyPrint.add_string ppstrm "(";
  57.        PPType.ppType env ppstrm typ;
  58.        PrettyPrint.add_string ppstrm ")"))
  59.  
  60.     fun print_sym (s: Symbol.symbol) = say (Symbol.name s);
  61.  
  62.     fun comma_seq elems =
  63.       let fun prElems [el] = say el
  64.         | prElems (el::rest) = (say el; say ", "; prElems rest)
  65.         | prElems [] = ()
  66.        in prElems elems
  67.       end
  68.  
  69.     fun print_and_seq pr elems =
  70.       let val old_and_seq = (!and_seq)
  71.           fun prElems (el::rest) = (pr el; and_seq := true; prElems rest)
  72.         | prElems [] = ()
  73.        in prElems elems;
  74.       and_seq := old_and_seq
  75.       end
  76.  
  77.  
  78.     fun print_entry (name, f) = 
  79.       let val (_,start_line,_) = Source.filepos inputSource (!current_pos)
  80.       val (_,end_line,_) = Source.filepos inputSource (!limit_pos) in
  81.         say name; say " "; 
  82.     say ((makestring start_line) ^ " ");
  83.     say ((makestring (!current_pos)) ^ " ");
  84.     say (if (!and_seq) then "A " else "X ");
  85.     say ((makestring end_line) ^ " ");
  86.     say ((makestring (!limit_pos)) ^ " ");
  87.     say "\127 ";
  88.         f();
  89.         nl()
  90.       end;
  91.  
  92.     fun printPat (VARpat (v as VALvar{typ=ref t,name,...})) =
  93.       print_entry (formatQid name, fn()=>(say "val "; print_type t))
  94.       | printPat (LAYEREDpat (v,p)) = (printPat(v); printPat(p))
  95.       | printPat (RECORDpat{fields,...}) = app (printPat o #2) fields
  96.       | printPat (VECTORpat (pats,_)) = app printPat pats
  97.       | printPat (APPpat(_,_,p)) = printPat p
  98.       | printPat (CONSTRAINTpat (p,_)) = printPat p
  99.       | printPat _ = ()
  100.  
  101.     and printDec(VALdec vbs) = 
  102.            print_and_seq (fn VB{pat,...} => printPat pat) vbs
  103.       | printDec(VALRECdec rvbs) = 
  104.            print_and_seq (fn RVB{var,...} => printPat(VARpat var)) rvbs
  105.       | printDec(TYPEdec tbs) =
  106.           (print_and_seq
  107.              (fn (TB{tyc=DEFtyc{path=name::_, tyfun=TYFUN{arity,...},...},def}) =>
  108.            print_entry(Symbol.name name, 
  109.                fn()=>(say "type ";
  110.                   case arity
  111.                       of 0 => ()
  112.                     | 1 => (say "'a ")
  113.                     | n => (say "(";
  114.                         comma_seq (PPType.typeFormals n);
  115.                         say ") ");
  116.                   print_type def))
  117.            | _ => ErrorMsg.impossible "Index0")
  118.           tbs)
  119.       | printDec(DATATYPEdec{datatycs,withtycs}) =
  120.           (print_and_seq 
  121.              (fn GENtyc{path=name::_, arity, kind=ref(DATAtyc dcons),...} =>
  122.                   print_entry(Symbol.name name, fn()=>say "datatype")
  123.                   (* app (fn DATACON{name,...} =>
  124.                   print_entry(Symbol.name name,fn()=>()))
  125.              dcons *)
  126.                | _ => ErrorMsg.impossible "Index3")
  127.              datatycs)
  128.       | printDec(ABSTYPEdec{abstycs, withtycs, body}) =
  129.           (app (fn GENtyc{path=name::_, kind=ref(DATAtyc dcons),...} =>
  130.                  (print_entry(Symbol.name name, fn()=>say "abstype ");
  131.                   app (fn (DATACON{name,...}) => 
  132.                   print_entry(Symbol.name name,fn()=>()))
  133.                dcons)
  134.            | GENtyc{path=name::_,...} =>
  135.               print_entry(Symbol.name name, fn()=> say "abstype ")
  136.                | _ => ErrorMsg.impossible "Index4")
  137.              abstycs;
  138.        printDec body)
  139.       | printDec(EXCEPTIONdec ebs) =
  140.           (print_and_seq
  141.              (fn (EBgen{exn=DATACON{name,...},etype,...}) =>
  142.                    print_entry(Symbol.name name,
  143.                    fn()=>(say "exn";
  144.                       case etype of NONE => ()
  145.                      | SOME ty' => (say " of ";
  146.                             print_type ty')))
  147.                | (EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =>
  148.                    print_entry(Symbol.name name,
  149.                    fn()=>(say "exn "; say(Symbol.name dname))))
  150.              ebs)
  151.       | printDec(STRdec sbs) =
  152.           (app (fn (STRB{strvar=STRvar{name,...},def,...}) =>
  153.                  (print_entry(Symbol.name name, fn()=>say "structure");
  154.                   printStrexp def))
  155.              sbs)
  156.       | printDec(ABSdec sbs) = printDec(STRdec sbs)
  157.       | printDec(FCTdec fbs) =
  158.       let fun printFctExp (FCTfct{def,...}) = printStrexp def
  159.         | printFctExp (VARfct{def=FCTvar{name=fname',...},...}) =
  160.                     print_entry(Symbol.name fname', fn()=> print "functor ")
  161.         | printFctExp (LETfct(dec,fct)) = (
  162.             printDec dec;
  163.             printFctExp fct)
  164.        in (app (fn (FCTB{fctvar=FCTvar{name=fname,...}, def}) =>
  165.                      (print_entry(Symbol.name fname, fn()=> print "functor ");
  166.                       printFctExp def))
  167.                fbs)
  168.       end
  169.       | printDec(SIGdec sigvars) =
  170.           app (fn SIGvar{name,...} =>
  171.            print_entry(Symbol.name name, fn()=>say "signature"))
  172.             sigvars
  173.       | printDec(FSIGdec fsigvars) =
  174.           app (fn FSIGvar{name,...} =>
  175.            print_entry(Symbol.name name, fn()=>say "fsignature"))
  176.             fsigvars
  177.       | printDec(LOCALdec(inner,outer)) = printDec(outer)
  178.       | printDec(SEQdec decs) = app printDec decs
  179.       | printDec(OPENdec strVars) = ()
  180.       | printDec(MARKdec(dec,L1,L2)) = withpos(L1,L2, fn()=>printDec(dec))
  181.       | printDec(FIXdec _) = ()
  182.       | printDec(OVLDdec _) = ()
  183.       | printDec _ = ErrorMsg.impossible "Index2"
  184.     
  185.     and printStrexp(VARstr(STRvar{name,...})) = ()
  186.       | printStrexp(STRUCTstr{body,...}) = app printDec body
  187.       | printStrexp(APPstr{oper=FCTvar{name,...}, argexp,...}) = ()
  188.       | printStrexp(LETstr(dec,body)) = printStrexp(body)
  189.       | printStrexp(MARKstr(body,L1,L2)) =withpos(L1,L2,fn()=>printStrexp body)
  190.   in
  191.     (printDec absyn; nl())
  192.   end
  193.  
  194. end
  195.